The Arsenal Files 6/The Arsenal Files 6 (Arsenal Computer).ISO/prg_basi/ddfedit.zip/AUTOTABS.BAS

BASIC Source File | 1996-02-02 | 11KB | 351 lines

Option Explicit

Declare Function nlWinSetTabStops Lib "User" Alias "SendMessage" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long

Declare Function nlWinAPI_GetTextExtent Lib "GDI" Alias "GetTextExtent" (ByVal hDC As Integer, ByVal lpString As String, ByVal nCount As Integer) As Long
Declare Function nlWinAPI_GetDialogBaseUnits Lib "User" Alias "GetDialogBaseUnits" () As Long

Global Const nWM_USER = 1024
Global Const nLB_SETTABSTOPS = nWM_USER + 19
Global Const nEM_SETTABSTOPS = nWM_USER + 27
Global Const nCB_SELECTSTRING = nWM_USER + 13
Global Const nLB_SELECTSTRING = nWM_USER + 13

Global Const nSEARCH_FROM_TOP = -1

Function AutoSetTabStopsCheck (ListCtrl As Control, TextCtrl As Control, tfUseHeadingWidthsOnly As Integer, SetDefaultTabs As Integer) As Integer

'This function automatically calculates and sets appropriate
'tabstops for a multi-column listbox, based on the actual data
'in the listbox.  You do not have to tell the function how many
'columns you want, nor figure out how wide each column should be;
'the actual data placed into the listbox determines that.

'In addition to the listbox, the function also sets identical
'tabstops in an accompanying, multi-line textbox.  This textbox
'provides the data for the column headings.

'tfUseHeadingWidthsOnly:
'  True -  Tabstops are calculated based only on the
'          widths of the column headings. This option
'          is must faster, but you're gambling that the
'          actual data will always be narrower than the
'          headings.
'
'  False - Tabstops are calculated based on the widest
'          entry in each column; both the headings and
'          the data are examined.  This option is slower
'          because each entry in the listbox must be
'          parsed, but it eliminates the guesswork.

'SetDefaultTabs:
'  True -  Tabstops are reset to Windows' default intervals
'          of 8 dialog units.
'
'  False - Tabstops are calculated based on the actual
'          data in the listbox/textbox.
'
'
'The function itself returns FALSE if any of the control
'verification tests fail; otherwise it returns TRUE.


Dim sColHeadings As String, sColData As String, sColString As String
Dim sParentFontName As String, fParentFontSize As Single
Dim tfParentFontBold As Integer, tfParentFontItalic As Integer
Dim nColCount As Integer, nDataWidth As Integer, nSpaceBetweenCols As Integer
Dim nMaxListboxCols As Integer, nNbrListboxCols As Integer, nNbrTabstops As Integer
Dim nInStart As Integer, nTabPos As Integer
Dim nlistsub As Integer, nTabSub As Integer
Dim nlRC As Long
Dim nListFontAvgWidth As Integer, nSystemFontAvgWidth As Integer
Dim fListFontPixelsPerDlgUnit As Single, fFontRatio As Single
Dim i As Integer
Dim nColWidth() As Integer  'measured column widths
Dim nTabstop() As Integer   'calculated WinAPI tabstops

Dim Msg As String
'================
Main:
'================


GoSub VerifyControls
GoSub Initialize

If SetDefaultTabs Then
   nNbrTabstops = 0
   GoSub UpdateCtrls
Else
   'Since VB provides an hDC property for forms, but
   'not for controls, we must temporarily set the parent
   'form's font characteristics equal to the listbox's
   'font characteristics.  Doing this ensures that all
   'text measurements made using the form's DC will be
   'accurate for the listbox.

   sParentFontName = ListCtrl.Parent.FontName
   fParentFontSize = ListCtrl.Parent.FontSize
   tfParentFontBold = ListCtrl.Parent.FontBold
   tfParentFontItalic = ListCtrl.Parent.FontItalic
   ListCtrl.Parent.FontName = ListCtrl.FontName
   ListCtrl.Parent.FontSize = ListCtrl.FontSize
   ListCtrl.Parent.FontBold = ListCtrl.FontBold
   ListCtrl.Parent.FontItalic = ListCtrl.FontItalic

   'Identify and measure the width of the column headings
   'present in the textbox.

   GoSub MeasureColHeadingWidths

   'Measure the width of the column data values present
   'in the listbox.

   If Not tfUseHeadingWidthsOnly Then
      GoSub MeasureColDataWidths
   End If

   'Calculate and set the necessary tabstop values, based
   'on the maximum width of each column.

   GoSub UpdateCtrls

   'Reset the parent form's font characteristics to their
   'original values.

   ListCtrl.Parent.FontName = sParentFontName
   ListCtrl.Parent.FontSize = fParentFontSize
   ListCtrl.Parent.FontBold = tfParentFontBold
   ListCtrl.Parent.FontItalic = tfParentFontItalic
End If

Exit Function


'==========================
VerifyControls:
'==========================
'Make sure both controls are of the proper type,
'and that the necessary property values are set.

If TypeOf ListCtrl Is ListBox Then
  ' nothing
Else
   Exit Function
End If

If TypeOf TextCtrl Is TextBox Then
  ' nothing
Else
   Exit Function
End If

If ListCtrl.Columns <> 0 Then
   Exit Function
End If

If TextCtrl.MultiLine = False Then
   Exit Function
End If

If TextCtrl.BorderStyle <> 0 Then
   Exit Function
End If

If Len(TextCtrl.Text) = 0 Then
   Exit Function
End If

Return

'======================
Initialize:
'======================
'A little extra space between columns helps
'to mitigate the inevitable rounding errors
'that will occur in the tabstop calculations.

nSpaceBetweenCols = 3

nMaxListboxCols = 10
ReDim nColWidth(nMaxListboxCols)

Return

'===================================
MeasureColHeadingWidths:
'===================================
'Search for TAB characters in the column heading
'text.  For each column found, measure the width
'of the heading text.

sColHeadings = TextCtrl.Text
nNbrListboxCols = 1

nInStart = 1
Do
   nTabPos = InStr(nInStart, sColHeadings, Chr$(9))

   If nTabPos > 0 Then
      sColString = Mid$(sColHeadings, nInStart, nTabPos - nInStart)
   Else
      sColString = Mid$(sColHeadings, nInStart, Len(sColHeadings) - nInStart + 1)
   End If

   'Measure the length of the string, in pixels;
   'this value is the current "column width".

   sColString = sColString + Space$(nSpaceBetweenCols)
   nColWidth(nNbrListboxCols) = nlWinAPI_GetTextExtent(ListCtrl.Parent.hDC, sColString, Len(sColString)) Mod 65536



   If nTabPos > 0 Then
      nNbrListboxCols = nNbrListboxCols + 1

      'Allocate space for more columns, if necessary

      If nNbrListboxCols > nMaxListboxCols Then
     nMaxListboxCols = nNbrListboxCols
     ReDim Preserve nColWidth(nMaxListboxCols)
      End If

      If nTabPos < Len(sColHeadings) Then
     nInStart = nTabPos + 1
      End If
   End If
Loop Until nTabPos = 0

nNbrTabstops = nNbrListboxCols - 1

Return

'================================
MeasureColDataWidths:
'================================
'Search for TAB characters in the listbox data.
'For each column found, measure the width of
'the data.

For nlistsub = 0 To ListCtrl.ListCount - 1

    If Len(ListCtrl.List(nlistsub)) > 0 Then
      sColData = ListCtrl.List(nlistsub)
      nColCount = 1

      nInStart = 1
      Do
      nTabPos = InStr(nInStart, sColData, Chr$(9))
      'Debug.Print nTabPos
      If nTabPos > 0 Then
        sColString = Mid$(sColData, nInStart, nTabPos - nInStart)
        'Debug.Print sColString
      Else
        sColString = Mid$(sColData, nInStart, Len(sColData) - nInStart + 1)
      End If

      'Measure the length of the string, in pixels

      sColString = sColString + Space$(nSpaceBetweenCols)
      nDataWidth = nlWinAPI_GetTextExtent(ListCtrl.Parent.hDC, sColString, Len(sColString)) Mod 65536

      ' Debug.Print ">"; sColString; "< W:"; nDataWidth

      'Ignore data columns for which there is no heading.

      If nColCount <= nNbrListboxCols Then
        'If any data value is wider than the current column width,
        'it becomes the new column width.

        If nDataWidth > nColWidth(nColCount) Then
        nColWidth(nColCount) = nDataWidth
        End If
      End If

      If nTabPos > 0 Then
        nColCount = nColCount + 1

      '  If nTabPos < Len(sColData) Then
      '     nInStart = nTabPos + 1
      '  End If
      End If
      nInStart = nTabPos + 1
      Loop Until nTabPos = 0
    End If

Next

Return

'==========================
UpdateCtrls:
'==========================
'Set the textbox font characteristics equal
'to the listbox font characteristics.

TextCtrl.Enabled = False
TextCtrl.FontName = ListCtrl.FontName
TextCtrl.FontSize = ListCtrl.FontSize
TextCtrl.FontBold = ListCtrl.FontBold
TextCtrl.FontItalic = ListCtrl.FontItalic
TextCtrl.Move ListCtrl.Left, ListCtrl.Top - TextCtrl.Height, ListCtrl.Width, TextCtrl.Height

ReDim nTabstop(nNbrTabstops)

'Calculate tabstop values for each column, in "dialog units"

If nNbrTabstops > 0 Then
   'Get the average character widths, in pixels, of the
   'listbox font and the system font.

   nListFontAvgWidth = (nlWinAPI_GetTextExtent(ListCtrl.Parent.hDC, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz", 52) Mod 65536) / 52
   nSystemFontAvgWidth = nlWinAPI_GetDialogBaseUnits() Mod 65536

   'A "dialog unit" is defined as 1/4 of the average
   'character width of the system font, in pixels.
   'We've already measured the width of each column,
   'in pixels, but it's not accurate enough to simply
   'divide one value into the other.

   'Note that errors in precision will start to creep in
   'at this point, due to integer rounding and intermediate
   'calculation results.  Experience shows that a little
   'extra white space between the data columns helps to
   'compensate (see "nSpaceBetweenCols").

   'Since a dialog unit is based on the system font,
   'not the font we're actually using in the listbox,
   'we must factor in the difference between the two
   'average character widths.  Thus, a more accurate
   'divisor is calculated as follows.

   fFontRatio = nListFontAvgWidth / nSystemFontAvgWidth
   fListFontPixelsPerDlgUnit = (nSystemFontAvgWidth * fFontRatio) / 4

   'Set a tabstop at the dialog unit closest to the
   'right-hand boundary (width) of each column.

   nTabstop(0) = nColWidth(1) / fListFontPixelsPerDlgUnit
   For nTabSub = 2 To nNbrTabstops
      nTabstop(nTabSub - 1) = nTabstop(nTabSub - 2) + nColWidth(nTabSub) / fListFontPixelsPerDlgUnit
   Next
Else
   nTabstop(0) = 0
End If

'Activate the tabstops.


nlRC = nlWinSetTabStops(TextCtrl.hWnd, nEM_SETTABSTOPS, nNbrTabstops, nTabstop(0))
nlRC = nlWinSetTabStops(ListCtrl.hWnd, nLB_SETTABSTOPS, nNbrTabstops, nTabstop(0))

'Redraw the controls.

TextCtrl.Refresh
ListCtrl.Refresh

Return

End Function